perm filename PLTCMX.F4[MSS,LCS]2 blob
sn#107258 filedate 1974-06-16 generic text, type T, neo UTF8
00100 C**** PLTCMD, FILLMS, ROTATE *********
38800 SUBROUTINE PLTCMD
38900 CC IMPLICIT INTEGER(A-Q,S-Z)
39000 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
39100 DIMENSION NMS(8),RMOV1(8),RMOV2(8)
39200 COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
39400 COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
39700 EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
39800 1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
39950 F78F(1)='(78F)'
39960 FA5(1)='(A5) '
39970 FA1(1)='(A1) '
40000
40100 IF(I2.NE.'X')GO TO 1
40150 CC ML=' '
40200 I2=0
40300 RXC=0
40400 RMOV1(1)='Y'
40500 NAME=0
40600 14 KA=0
40700 3 KA=KA+1
40710 CC IF(ML.EQ.' ')GO TO 15
40715 IF(ML.EQ.0)GO TO 15
40720 K=K-2
40725 ML=ML-1
40730 IF(ML.EQ.0)GO TO 10
40740 GO TO 31
40800 15 TYPE 2,KA
40900 ACCEPT 11,K,ML
40950 C TYPE LAST NAME, NUMBER FOR A SERIES
41000 50 IF(K.EQ.' ')GO TO 10
41100 IF(K.EQ.'99')GO TO 140
41200 C 99=BACKUP
41300 31 IF(LOOKD(K))GO TO 56
41400 C JUMP IF FILE FOUND
41500 TYPE 55
41600 GO TO 15
41700 55 FORMAT(' FILE NOT FOUND'/)
41750 11 FORMAT(A5,I)
41800 56 NMS(KA)=K
41810 CC IF(ML.EQ.' ')GO TO 5
41820 IF(ML.EQ.0)GO TO 5
41855 RJH='Y'
41877 GO TO 21
41900 5 TYPE 8
42000 ACCEPT FA5,RJH
42100 IF(RJH.EQ.'99')GO TO 15
42200 IF(RJH.NE.'Y')RJH=0
42300 IF(RJH.EQ.0)REREAD F78F,RJH
42400 C MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
42500 21 RMOV1(KA+1)=RJH
42600 RMOV2(KA)=RJH
42700 GO TO 3
42800 140 KA=KA-1
42900 GO TO 15
43000
43100 10 KB=KA-1
43110 IF(I3.NE.'G')GO TO 22
43120 RSIZ=1
43130 GO TO 222
43200 22 TYPE 9
43300 ACCEPT F78F,RSIZ
43400 IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
43500 222 KA=0
43600
43700 1 IF(NAME.NE.0)GO TO 12
43800 IF(KA.EQ.KB)CALL PLOT(0,0,99)
43900 NAME=NMS(KA+1)
44000 TYPE 111,NAME
44100 RETURN
44200 12 KA=KA+1
44300 NAME=0
44400 RJD=1
44500 IF(INP(3).EQ.'C')RJD=0
44600 C 'PXC' = CALCOMP OUTPUT
44700 RJH=0
44800 RJB=RSIZ
44900 RJC=RSIZ
45000 RJG=0
45100 RJE=1
45200 RJF=1
45300 IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
45400 IF(RMOV1(KA).NE.0)RJE=0
45500 IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
45600 2 FORMAT(' TYPE FILE NAME',I2,1X$)
45700 8 FORMAT(' MOVE UP AT END? ',$)
45800 9 FORMAT(' SIZE FACTOR? ',$)
45900 111 FORMAT(1XA5/)
46000 END
60800
62000
63500
65000 C****** CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
65100 SUBROUTINE FILLMS(L,IDAT,RJB,CENTR,RJF,RJG)
65200 COMMON/DL/IXRX,SAVER,NAME
65300 COMMON/DST/BB,CC/FLM/X(200),Y(200),NX(200)
65400 DIMENSION IDAT(1)
65500 COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJC
65600 DATA MP/2/,MD/6/
65700 C MD=DISPLAY MP=PLOTTER MX=XGP
65800 DX=DIS
65900 RX=RHT
66000 D=RSTJC*RJF
66100 R=RSTJC*RJG
66200 4 GO TO 1
66300 C=CC
66400 B=BB
66500 C SAVES IT. IT WILL RETURN LATER.
66600 BB=B/DIS
66700 CC=1000
66800 1 KK=0
66900 DO 205 J=1,L
67000 CALL UNPACK(M,N,IDAT(J))
67100 KK=KK+1
67200 NX(KK)=0
67300 IF(LL.EQ.3)NX(KK)=3
67400 X(KK)=ROFF((RJB+D*M)*DIS)
67500 Y(KK)=ROFF((CENTR+R*N)*RHT)
67600 3 GO TO 205
67700 Y(KK)=Y(KK)*(C-BB*(ABS(X(KK))))
67800 C FOR DISTORTION
67900 205 CONTINUE
68000 NX(1)=KK
68100 DIS=1.0
68200 RHT=DIS
68300 M=MD
68400 IF(IPLT)M=MP-IXRX
68500 C STOPS DISTORTION IN 'LINES'
68600 2 CALL FILLER(X,Y,NX,M)
68700 DIS=DX
68800 RHT=RX
68900 5 RETURN
69000 C NEXT TO RESET DISTORTION FACT.
69100 BB=B
69200 CC=C
69300 RETURN
69400 END
69500
69600 SUBROUTINE ROTATE(I,L)
69700 DIMENSION I(1)
69800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RR(8),RSTJC
69900 EQUIVALENCE (RJF,RJQ(4)),(RJG,RJQ(5)),(DEG,RJQ(7))
70000 RJG=RJG*RSTJC
70100 RJF=RJF*RSTJC
70200 N=I(L)
70300 KNT=501
70400 C ROTATED DATA IS PUT BACK STARTING AT LOCATION 501.
70500 I(KNT)=N
70600 DO 1 K=L+1,N+L-1
70700 CALL UNPACK(J,M,I(K))
70800 X=J*RJF
70900 Y=M*RJG
71000 JJ=I(K)/100000000
71100 AX=ATAN2(X,Y)*57.29578
71200 HYP=SQRT(X**2+Y**2)
71300 ROT=DEG+AX
71400 J=ROFF(HYP*COSD(ROT))
71500 M=ROFF(HYP*SIND(ROT))
71600 KNT=KNT+1
71700 IF(J)J=1000-J
71800 IF(M)M=1000-M
71900 1 I(KNT)=M*10000+J+JJ*100000000
72000 L=501
72100 RJF=1.
72200 RJG=1.
72300 RSTJC=1.
72400 C SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
72500 END